Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/lisp/clue.lha/clue/examples/old/valuators.l

Text File | 1989-07-12 | 27.1 KB | 774 lines

;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Lowercase:T; Base:10; Syntax:Common-Lisp -*-
;;;
;;;             TEXAS INSTRUMENTS INCORPORATED
;;;                  P.O. BOX 2909
;;;                   AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1988 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

;;;
;;; Description:  Valuator contacts
;;;
;;; Change History:
;;; ----------------------------------------------------------------------------
;;; 10/27/87   KK    Created
;;;  6/09/88   KK    Updated to TICLOS v7, CLUE v13
;;;  6/14/88   KK    Removed scale, use floating pt value range
;;;  6/21/88   KK    Added precision slot
;;;  7/15/88   SLM   Add call to '(the VALUATOR self)' in VALUATOR-SET-BY-USER
;;;  8/26/88   SLM   Changed doc strings to be useful for the mouse-documentation window


;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                                     valuator                                     |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(in-package 'clue-examples :use '(lisp xlib clos cluei))



(defcontact valuator (contact)
  ((fg-color        :type      pixel
            :initarg   :fg-color
            :accessor  fg-color
            :initform  0
                    )
   (bg-color        :type      pixel
            :initarg   :bg-color
            :accessor  bg-color
            :initform  1
                    )
   (minimum         :type      number
            :initarg   :minimum
            :accessor  valuator-minimum
            :initform  0)
   (maximum         :type      number
            :initarg   :maximum
            :accessor  valuator-maximum
            :initform  0)
   (value           :type      number
            :initarg   :value
            :accessor  valuator-value
            :initform  0)
   (indicator-size  :type      number
            :initarg   :indicator-size
            :accessor  valuator-indicator-size
            :initform  1)
   (increment       :type      number
            :initarg   :increment
            :accessor  valuator-increment
            :initform  1)
   (precision       :type      (or null number)
            :initarg   :precision
            :accessor  valuator-precision
            :initform  1)
   (documentation   :initform   "L: more  M: move to here  R: less"))
  (:resources       increment
            fg-color
            bg-color
            documentation
            (event-mask :initform #.(make-event-mask :pointer-motion-hint)))
  (:documentation   "A basic valuator which controls a numeric value."))


(proclaim '(inline precision-round))
(defun precision-round (value precision)
  (if precision
      (* precision (round value precision))
      value))



;;;  Setting values

(defmethod initialize-instance :after ((self valuator) &key &allow-other-keys)
  ;; Ensure that indicator is initialized
  (valuator-change-indicator self (valuator-indicator-size self)))

(defmethod (setf valuator-minimum) (min (self valuator))
  (valuator-calibrate self :minimum min))

(defmethod (setf valuator-maximum) (max (self valuator))
  (valuator-calibrate self :maximum max))

(defmethod (setf valuator-indicator-size) (new-size (self valuator))
  (valuator-calibrate self :indicator-size new-size))

(defmethod (setf valuator-value) (new-value (self valuator))
  (with-slots (maximum minimum) self
    (unless (and (<= new-value maximum) (>= new-value minimum))
    (error "Invalid value: ~a is not in the range (~a ~a)." new-value minimum maximum)))
  (valuator-calibrate self :value new-value))

(defmethod valuator-calibrate ((self valuator) &key minimum maximum value indicator-size)
  (with-slots ((slot-minimum minimum)
               (slot-maximum maximum)
               (slot-value value)
               (slot-indicator-size indicator-size))
              self
    ;; Set default argument values
    (setf minimum        (or minimum slot-minimum)
      maximum        (or maximum slot-maximum)
      indicator-size (or indicator-size slot-indicator-size)
      value          (max (min (or value slot-value) maximum) minimum))

    (let* ((range-changed     (or (/= minimum slot-minimum)
                  (/= maximum slot-maximum)
                  (/= indicator-size slot-indicator-size)))
       (value-changed     (/= value slot-value)))

      ;; Erase previous indicator
      (when (realized-p self) (valuator-erase-indicator self))

      (when  range-changed
    ;; Check for valid range
    (assert (<= minimum maximum)
        nil "Minimum (~a) exceeds maximum (~a)."
        minimum  maximum)

    ;; Adjust internal conversions for new range and indicator size
    (valuator-adjust-size self minimum maximum indicator-size)
    (valuator-change-indicator self indicator-size))

      ;; Update instance variables
      (setf slot-minimum        minimum
        slot-maximum        maximum
        slot-value          value
        slot-indicator-size indicator-size)

      ;; Reposition indicator
      (valuator-move-indicator self value)

      ;; Redisplay, if necessary
      (when (realized-p self) (display self))

      ;; Report program-requested value change
      (if value-changed (apply-callback self :changed-by-program value)))))


(defmethod valuator-adjust-size ((self valuator) new-minimum new-maximum  new-indicator-size)
  "Adjust the valuator size to new value range. The primary method for valuators is undefined."
  (declare (ignore  new-minimum new-maximum  new-indicator-size)))



;;; Indicator control

(defmethod valuator-change-indicator ((self valuator) new-indicator-size)
  "Change the size of the valuator indicator.  NEW-INDICATOR-SIZE is given in the
same units measure by the valuator."
  (declare (ignore   new-indicator-size)))

(defmethod valuator-move-indicator ((self valuator) new-value)
  "Change the indicator position to reflect the NEW-VALUE."
  (declare (ignore new-value)))

(defmethod valuator-indicator-changed-p ((self valuator) new-value)
  "Return true if setting NEW-VALUE will cause indicator display to change.
This predicate is used to avoid unnecessary display updates."
  (declare (ignore new-value))
  t)

(defmethod valuator-display-indicator ((self valuator)))
(defmethod valuator-erase-indicator ((self valuator)))

;;; Actions


(defmethod more ((self valuator))
  "Initiate an operation to increment the valuator value.
The primary valuator method does nothing. See FINISH-MORE.")

(defmethod finish-more ((self valuator))
  "Conclude an operation to increment the valuator value."
  (with-slots (value maximum increment) self
      (when (< value maximum)
        (valuator-set-by-user self (min (+ value increment) maximum)))))

(defmethod less ((self valuator))
  "Initiate an operation to decrement the valuator value.
The primary valuator method does nothing. See FINISH-LESS.")

(defmethod finish-less ((self valuator))
  "Conclude an operation to decrement the valuator value."
  (with-slots (value minimum increment) self
    (when (> value minimum)
      (valuator-set-by-user self (max (- value increment) minimum)))))

(defmethod here ((self valuator))
  "Initiate an operation to directly position the valuator value.
The primary valuator method does nothing. See FINISH-HERE.")

(defmethod finish-here ((self valuator))
  "Conclude an operation to directly position the valuator value.
The primary valuator method does nothing.")



;;; Inquiry

(defmethod valuator-per-cent ((self valuator))
  "Return the current value as a percentage of the total range (i.e. (- maximum minimum))."
  (with-slots (value minimum maximum) self
    (let ((range (- maximum minimum)))
      (if (plusp range)
      (float (/ (- value minimum) range))
      1.0))))

;;; Internal
(defun valuator-set-by-user (self new-value)
  ;; Echo new value
  (when (valuator-indicator-changed-p self new-value)
    (valuator-erase-indicator self)
    (valuator-move-indicator self new-value)
    (valuator-display-indicator self))

  (with-slots (value) (the valuator self)  ;;add '(THE valuator...) so kludged CLOS can macro expand correctly
    ;; Change value
    (setf value new-value)

    ;;Report new value
    (apply-callback self :changed-by-user value)))


;;; Class bindings

(defevent valuator (:button-release :button-1) finish-more)
(defevent valuator (:button-press   :button-1) more)
(defevent valuator (:button-release :button-3) finish-less)
(defevent valuator (:button-press   :button-3) less)
(defevent valuator (:button-release :button-2) finish-here)
(defevent valuator (:button-press   :button-2) move-here here)
(defevent valuator (:motion-notify  :button-2) move-here)


;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                                     scroller                                     |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(defvar *scroller-initial-delay*
    0.35 "Seconds to delay before beginning continuous scrolling.")
(defvar *scroller-delay*
    0.10 "Seconds to delay before changing value during continuous scrolling.")

(defcontact scroller (valuator)
  (;; Internal
   (pixels-per-unit  :type number  :initform 0)
   (thumb-position   :type integer :initform 0)
   (thumb-size       :type integer :initform 0)
   (scroll-state               :initform :idle
                  :type (member :idle :more :here :less :continuous-more :continuous-less))
   (documentation :initform '(("L: more  M: move to here  R: less")
                 ("Click-hold does the appropriate action continually"))))
  (:resources documentation
              fg-color
              bg-color
              fill-style)

  (:documentation    "A scroll bar valuator."))

(define-resources
   (* scroller  * fg-color) 0
   (* scroller  * bg-color) 1
   (* scroller * fill-style) :opaque-stippled)

;;; Indicator control

(defmethod valuator-change-indicator ((self scroller) new-indicator-size)
  "Change the size of the scroller thumb.  NEW-INDICATOR-SIZE is given in the
same units measure by the scroller."
  (with-slots (thumb-size pixels-per-unit) self
    (setf thumb-size (round (* new-indicator-size pixels-per-unit)))))

(defmethod valuator-move-indicator ((self scroller) new-value)
  "Change the thumb position to reflect the NEW-VALUE."
  (with-slots (thumb-position pixels-per-unit minimum) self
    (setf thumb-position (round (* pixels-per-unit (- new-value minimum))))))

(defmethod valuator-indicator-changed-p ((self scroller) new-value)
  "Return true if setting NEW-VALUE will cause indicator display to change.
This predicate is used to avoid unnecessary display updates."
  (with-slots (thumb-position pixels-per-unit minimum) self
    (/= thumb-position (round (* pixels-per-unit (- new-value minimum))))))

;;; Display

(defmethod display ((self scroller) &optional x y width height &key)
  (declare (ignore x y width height))
  ;; Display thumb against background
  (valuator-display-indicator self))


;;; Actions

(defmethod more ((self scroller))
  "Initiate an operation to increment the scroller value.
This method implements the continuous scrolling feature."
  (with-slots (scroll-state value maximum increment) self
    (when (eq scroll-state :idle)
      (setf scroll-state :more)

      ;; Continuous scrolling loop
      (do ((display (drawable-display self))
        (delay   *scroller-initial-delay*))
      ((and (process-next-event display delay)
        (eq scroll-state :idle)))

    ;; Ensure continuous controlling scroll-state
    (setf delay *scroller-delay*
          scroll-state :continuous-more)

    (when (< value maximum)
      (valuator-set-by-user self (min (+ value increment) maximum)))))))

(defmethod finish-more ((self scroller))
  "Conclude an operation to increment the scroller value."
  (with-event (y)
    (with-slots (scroll-state value maximum minimum pixels-per-unit
                       increment indicator-size precision) self
      (case scroll-state
        (:more
         ;; Increment relative to event position
     (when (< value maximum)
           (valuator-set-by-user
         self (min maximum
               (+ value
              (max increment
                   (precision-round
                 (* indicator-size (/ y (- maximum minimum) pixels-per-unit))
                 precision))))))

         ;; Return to idle scroll-state
         (setf scroll-state :idle))

        (:continuous-more
         ;; Simply return to idle state
         (setf scroll-state :idle))))))

(defmethod less ((self scroller))
  "Initiate an operation to decrement the scroller value.
This method implements the continuous scrolling feature."
  (with-slots (scroll-state value minimum increment) self
    (when (eq scroll-state :idle)
      (setf scroll-state :less)

      ;; Continuous scrolling loop
      (do ((display (drawable-display self))
        (delay   *scroller-initial-delay*))
      ((and (process-next-event display delay)
        (eq scroll-state :idle)))

    ;; Ensure continuous controlling state
    (setf delay *scroller-delay*
          scroll-state :continuous-less)

    (when (> value minimum)
      (valuator-set-by-user self (max (- value increment) minimum)))))))

(defmethod finish-less ((self scroller))
  "Conclude an operation to decrement the scroller value."
  (with-event (y)
    (with-slots (scroll-state value maximum minimum pixels-per-unit
                       increment indicator-size precision) self
      (case scroll-state
        (:less
         ;; Decrement relative to event position.
         (when (> value minimum)
           (valuator-set-by-user
         self (max minimum
               (- value
              (max increment
                   (precision-round
                 (* indicator-size (/ y (- maximum minimum) pixels-per-unit))
                 precision))))))

         ;; Return to idle scroll-state
         (setf scroll-state :idle))

        (:continuous-less
         ;; Simply return to idle state
         (setf scroll-state :idle))))))


(defmethod here ((self scroller))
  "Initiate an operation to directly position the valuator value.
This method implements the drag scrolling feature."
  (with-slots (scroll-state) self
    (when (eq scroll-state :idle)
      (setf scroll-state :here)

      ;; Drag scrolling loop
      (do ((display (drawable-display self))
        (delay  *scroller-initial-delay*))
      ((and (process-next-event display delay)
        (eq scroll-state :idle)))

    ;; Ensure continuous controlling state
    (setf delay nil
          scroll-state :continuous-here)))))

(defmethod finish-here ((self scroller))
  "Conclude an operation to directly position the valuator value."
  (with-slots (scroll-state) self
    (if (eq scroll-state :here)
    ;; Position according to finish event
    (move-here self))

    ;; Return to idle state
    (setf scroll-state :idle)))



;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                                     vscroller                                    |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(defcontact vscroller (scroller)
  ()
  (:documentation  "A vertically-oriented scroll bar valuator. "))


;;; Display

(defmethod valuator-display-indicator ((self vscroller))
  (with-slots (fg-color bg-color thumb-position width height thumb-size) self
    (using-gcontext (gcontext :drawable   self
                  :foreground fg-color
                  :background bg-color
                  :fill-style :stippled 66%gray)
      (draw-rectangle self gcontext
              1 thumb-position
              (max 1 (- width 2)) thumb-size
              :fill-p)
      (draw-rectangle self gcontext
                      0 0 (- width 1) (- height 1)))))

(defmethod valuator-erase-indicator ((self vscroller))
  (with-slots (thumb-position width thumb-size) self
    (clear-area self
        :y      thumb-position
        :width  width
        :height thumb-size)))

;;; Size control

(defmethod valuator-adjust-size ((self vscroller) new-minimum new-maximum new-indicator-size)
  "Adjust internal data for new range and indicator size"
  (with-slots (height pixels-per-unit) self
    (let ((range (- new-maximum new-minimum)))
      (setf pixels-per-unit (/ height (if (plusp range) range new-indicator-size))))))


;;; Actions

(defmethod move-here ((self vscroller))
  "Change value according to position given by the EVENT."

  ;; Use event to trigger a request for the current pointer position
  (multiple-value-bind (x y) (query-pointer self)
    (declare (ignore x))
    (with-slots (value minimum maximum event-y pixels-per-unit precision) self
      (let ((new-value (max (min (precision-round
                   (+ minimum (/ y pixels-per-unit))
                   precision)
                                 maximum)
                            minimum)))
        (when (/= new-value value)
          (valuator-set-by-user self new-value))))))





;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                                     hscroller                                    |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(defcontact hscroller (scroller)
  ()
  (:documentation    "A horizontally-oriented scroll bar valuator."))


;;; Display

(defmethod valuator-display-indicator ((self hscroller))
  (with-slots (fg-color bg-color thumb-position thumb-size height width) self
    (using-gcontext (gcontext :drawable   self
                  :foreground fg-color
                  :background bg-color
                  :fill-style :solid)
      (draw-rectangle self gcontext
              thumb-position 1
              thumb-size (max 1 (- height 2))
              :fill)
      (draw-rectangle self gcontext
                      0 0 (- width 1) (- height 1)))))

(defmethod valuator-erase-indicator ((self hscroller))
  (with-slots (thumb-position thumb-size height) self
    (clear-area self
        :x      thumb-position
        :width  thumb-size
        :height height)))

;;; Size control

(defmethod valuator-adjust-size ((self hscroller) new-minimum new-maximum new-indicator-size)
  "Adjust internal data for new range and indicator size"
  (with-slots (width pixels-per-unit) self
    (let ((range (- new-maximum new-minimum)))
      (setf pixels-per-unit (/ width (if (plusp range) range new-indicator-size))))))


;;; Actions

(defmethod move-here ((self hscroller))
  "Change value according to position given by the EVENT."

  ;; Use event to trigger a request for the current pointer position
  (multiple-value-bind (x y) (query-pointer self)
    (declare (ignore y))
    (with-slots (value minimum maximum event-y pixels-per-unit precision) self
      (let ((new-value (max (min (precision-round
                   (+ minimum (/ x pixels-per-unit))
                   precision)
                                 maximum)
                            minimum)))
        (when (/= new-value value)
          (valuator-set-by-user self new-value))))))


;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                                     graduated-valuator                           |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+




;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                                     slider                                       |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(defcontact slider (scroller)
  (;; Internal
   (thumb-pixmap     :type (or null pixmap) :initform nil))
  (:documentation    "A slider valuator."))

;;; Indicator control

(defmethod valuator-change-indicator ((self slider) new-indicator-size)
  "Change the size of the slider thumb.  NEW-INDICATOR-SIZE is given in the
same units measure by the slider."
  (with-slots (thumb-pixmap thumb-size pixels-per-unit) self
    ;; Discard old image --- recreate upon display
    (when thumb-pixmap
      (free-pixmap thumb-pixmap)
      (setf thumb-pixmap nil))
    (setf thumb-size (round (* new-indicator-size pixels-per-unit)))))



;;;----------------------------------------------------------------------------------+
;;;                                                                                  |
;;;                                     vslider                                      |
;;;                                                                                  |
;;;----------------------------------------------------------------------------------+

(defcontact vslider (slider)
  ()
  (:documentation    "A vertically-oriented slider valuator."))

;;; Indicator control

(defmethod valuator-erase-indicator ((self vslider))
  (with-slots (thumb-position width thumb-size) self
    (clear-area self
        :y      thumb-position
        :width  width
        :height thumb-size)))


;;; Display (fix this!)

;(DEFMETHOD valuator-display-indicator ((self vslider))
;  (WITH-SLOTS (thumb-pixmap width thumb-size depth contact-background fg-color bg-color thumb-position) self
;    (USING-GCONTEXT (gcontext :foreground fg-color
;                  :background bg-color
;                  :fill-style :solid)
;      (UNLESS thumb-pixmap
;    ;; Create slider thumb pixmap
;    (SETF thumb-pixmap (create-pixmap :drawable self
;                      :width    width
;                      :height   thumb-size
;                      :depth    depth))
;    (LET* ((offset       (ROUND (MIN width thumb-size) 8))
;           (offset2      (ROUND offset 2))
;           (face-left    0)
;           (face-top     offset2)
;           (face-right   (- width offset))
;           (face-bottom  (- thumb-size offset2))
;           (shadow-width (MIN 3 (ROUND offset 3))))

;      ;; Draw background
;      (TYPECASE contact-background
;        (pixmap (WITH-GCONTEXT
;              (gcontext :fill-style :tiled :tile contact-background)
;              (DRAW-RECTANGLE thumb-pixmap gcontext
;                      0 0
;                      width thumb-size :fill-p)))
;        (t      (WITH-GCONTEXT
;              (gcontext :fill-style :solid :foreground contact-background)
;              (DRAW-RECTANGLE thumb-pixmap gcontext
;                      0 0
;                      width thumb-size :fill-p))))

;      ;; Draw shadow
;      (WITH-GCONTEXT
;        (gcontext :fill-style :solid)
;        (DRAW-RECTANGLE thumb-pixmap gcontext
;                shadow-width shadow-width
;                (- width shadow-width) (- thumb-size shadow-width) :fill-p))

;      ;; Draw sides
;      (WITH-GCONTEXT            ;top
;        (gcontext :fill-style :opaque-stippled :stipple (cluei:get-pixmap (root self) 25%gray))
;        (DRAW-LINES thumb-pixmap gcontext
;            (LIST face-right face-top
;                  width      0
;                  0          0
;                  face-left  face-top)
;            :fill-p t :shape :convex))

;      (WITH-GCONTEXT            ;bottom
;        (gcontext :fill-style :opaque-stippled :stipple (cluei:get-pixmap (root self) 66%gray))
;        (DRAW-LINES thumb-pixmap gcontext
;            (LIST width      thumb-size
;                  0          thumb-size
;                  face-left  face-bottom
;                  face-right face-bottom)
;            :fill-p t :shape :convex)
;        (DRAW-LINES thumb-pixmap gcontext    ;right
;            (LIST width      thumb-size
;                  face-right face-bottom
;                  face-right face-top
;                  width 0)
;            :fill-p t :shape :convex))

;      ;; Draw top
;      (WITH-GCONTEXT (gcontext :line-style :solid)
;        (DRAW-RECTANGLE thumb-pixmap gcontext 0 0 width thumb-size))
;      (WITH-GCONTEXT
;        (gcontext :fill-style :opaque-stippled :stipple (cluei:get-pixmap (root self) 12%gray))
;        (DRAW-RECTANGLE thumb-pixmap gcontext
;                face-left face-top
;                (- face-right face-left) (- face-bottom face-top) :fill-p))

;      ;; Draw notches
;      (LET* ((number-notches 1)
;         (notch-height (ROUND (- face-bottom face-top) 15))
;         (notch-y      (+ face-top
;                  (ROUND (- face-bottom face-top) (1+ number-notches))
;                  (ROUND notch-height 2)))
;         (notch-y-nh   (- notch-y notch-height))
;         (notch-y-nh2  (- notch-y (ROUND notch-height 2)))
;         (notch-x      (ROUND (- face-right face-left) 15))
;         (fl-nx        (+ face-left notch-x))
;         (w-nx         (- width notch-x)))
;        (DOTIMES (i number-notches)
;          (TYPECASE contact-background
;        (pixmap (WITH-GCONTEXT
;              (gcontext :fill-style :tiled :tile contact-background)
;              (DRAW-LINES thumb-pixmap gcontext
;                      (LIST face-left notch-y
;                        fl-nx     notch-y-nh2
;                        face-left notch-y-nh)
;                      :fill-p t :shape :convex)))
;        (t      (WITH-GCONTEXT
;              (gcontext :fill-style :solid :foreground contact-background)
;              (DRAW-LINES thumb-pixmap gcontext
;                      (LIST face-left notch-y
;                        fl-nx     notch-y-nh2
;                        face-left notch-y-nh)
;                      :fill-p t :shape :convex))))
;          (WITH-GCONTEXT
;        (gcontext :fill-style :opaque-stippled :stipple (cluei:get-pixmap (root self) 88%gray))
;        (DRAW-LINES thumb-pixmap gcontext
;                (LIST face-left notch-y-nh
;                  w-nx      notch-y-nh
;                  width     notch-y-nh2
;                  fl-nx     notch-y-nh2)
;                :fill-p t :shape :convex))
;          (WITH-GCONTEXT
;        (gcontext :fill-style :opaque-stippled :stipple (cluei:get-pixmap (root self) 33%gray))
;        (DRAW-LINES thumb-pixmap gcontext
;                (LIST w-nx      notch-y
;                  face-left notch-y
;                  fl-nx     notch-y-nh2
;                  width     notch-y-nh2)
;                :fill-p t :shape :convex))
;          (WITH-GCONTEXT
;        (gcontext :line-style :solid)
;        (DRAW-LINES thumb-pixmap gcontext
;                (LIST face-left notch-y
;                  fl-nx     notch-y-nh2
;                  face-left notch-y-nh
;                  w-nx      notch-y-nh
;                  width     notch-y-nh2
;                  w-nx      notch-y
;                  face-left notch-y)))
;          (INCF notch-y (ROUND (- face-bottom face-top) 4))
;          )))))
;    ;; Display thumb-pixmap
;    (WITH-GCONTEXT
;      (gcontext :fill-style :tiled :tile thumb-pixmap)
;      (DRAW-RECTANGLE self gcontext
;    0      thumb-position
;    width  thumb-size
;    :fill-p))))

;;; Size control

(defmethod valuator-adjust-size ((self vslider) new-minimum new-maximum  new-indicator-size)
  "Adjust internal data for new range and indicator size."
  (with-slots (height pixels-per-unit) self
    (setf pixels-per-unit (/ height (+ new-maximum (- new-minimum)  new-indicator-size)))))





;;; Actions

(defmethod move-here ((self vslider))
  "Change value according to position given by the EVENT."
  (with-event (y)
    (with-slots (value minimum maximum event-y pixels-per-unit indicator-size precision) self
      (let ((new-value (max (min (precision-round
                   (+ minimum (/ y pixels-per-unit) (round indicator-size -2))
                   precision)
                                 maximum)
                            minimum)))
        (when (/= new-value value)
          (valuator-set-by-user self new-value))))))